home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / SmallTalk / Behavior.st < prev    next >
Text File  |  1995-08-25  |  13KB  |  511 lines
  1. "======================================================================
  2. |
  3. |   Behavior Method Definitions
  4. |
  5.  ======================================================================"
  6.  
  7.  
  8. "======================================================================
  9. |
  10. | Copyright (C) 1990, 1991, 1992 Free Software Foundation, Inc.
  11. | Written by Steve Byrne.
  12. |
  13. | This file is part of GNU Smalltalk.
  14. |
  15. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  16. | under the terms of the GNU General Public License as published by the Free
  17. | Software Foundation; either version 1, or (at your option) any later version.
  18. | 
  19. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  20. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  21. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  22. | details.
  23. | 
  24. | You should have received a copy of the GNU General Public License along with
  25. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  26. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  27. |
  28.  ======================================================================"
  29.  
  30.  
  31. "
  32. |     Change Log
  33. | ============================================================================
  34. | Author       Date       Change 
  35. | sbb         20 Apr 91      added methodsFor:ifFeatures:
  36. |
  37. | sbb         16 Mar 91      Class creation now separate statement.
  38. |
  39. | sbb         10 Nov 90      Implemented compile:notifying:
  40. |
  41. | sbb          1 Nov 90      Fixed isBytes to return true only if the object is
  42. |              not pointers and not words.
  43. |
  44. | sbb         21 Sep 90      Changed allSubclassesDo: to use ALL subclasses, both
  45. |              direct and indirect.
  46. |
  47. | sbb         16 Sep 90      Implemented whichSelectorsReferTo: and
  48. |              scopeHas:ifTrue:.
  49. |
  50. | sbyrne     25 Apr 89      created.
  51. |
  52. "
  53.  
  54. Object subclass: #Behavior
  55.        instanceVariableNames: 'superClass subClasses 
  56.                                methodDictionary instanceSpec'
  57.        classVariableNames: ''
  58.        poolDictionaries: ''
  59.        category: nil
  60. !
  61.  
  62. Behavior comment: 
  63. 'I am the parent class of all "class" type methods.  My instances know
  64. about the subclass/superclass relationships between classes, contain
  65. the description that instances are created from, and hold the method
  66. dictionary that''s associated with each class.  I provide methods for
  67. compiling methods, modifying the class inheritance hierarchy, examining the
  68. method dictionary, and iterating over the class hierarchy.' !
  69.  
  70. CFunctionDescs at: #CFunctionGensym put: 1!
  71.  
  72. !Behavior class methodsFor: 'C interface'!
  73.  
  74. defineCFunc: cFuncNameString
  75.   withSelectorArgs: selectorAndArgs
  76.   forClass: aClass 
  77.   returning: returnTypeSymbol 
  78.   args: argsArray
  79.     | stream gensym descriptor |
  80.     "This is pretty complex.  What I want to provide is a very efficient way
  81.      of calling a C function.  I create a descriptor object that holds the
  82.      relevant information regarding the C function.  I then compile the
  83.      method that's to be invoked to call the C function.  This method uses the
  84.      primitive #255 to perform the actual call-out.  To let the primitive
  85.      know which descriptor to use, I arrange for the first and only method
  86.      literal of the compiled method to be an association that contains as
  87.      its value the C function descriptor object.  I add new associations to
  88.      the global shared pool 'CFunctionDescs', and reference the newly
  89.      generated key in the text of the compiled method."
  90.     gensym _ Symbol intern: ('CFunction' , CFunctionGensym printString).
  91.     CFunctionGensym _ CFunctionGensym + 1.
  92.     descriptor _ self makeDescriptorFor: cFuncNameString
  93.                       returning: returnTypeSymbol
  94.                   withArgs: argsArray.
  95.     CFunctionDescs at: gensym put: descriptor.
  96.     stream _ WriteStream on: (String new: 20).
  97.     stream nextPutAll: selectorAndArgs;
  98.     nextPutAll:
  99. '
  100.     <primitive: 255>
  101.     ^';
  102.     print: gensym.
  103.     aClass compile: stream contents
  104. !!
  105.  
  106.  
  107.  
  108. !Behavior methodsFor: 'creating method dictionary'!
  109.  
  110. methodDictionary: aDictionary
  111.     methodDictionary _ aDictionary
  112. !
  113.  
  114. addSelector: selector withMethod: compiledMethod
  115.     methodDictionary at: selector put: compiledMethod
  116. !
  117.  
  118. removeSelector: selector
  119.     methodDictionary removeKey: selector
  120. !
  121.  
  122. compile: code
  123.     (code isKindOf: PositionableStream)
  124.         ifTrue: [ code _ code contents ].
  125.     (code isMemberOf: String)
  126.         ifFalse: [ code _ code asString ].
  127.     ^self compileString: code
  128. !
  129.  
  130. compile: code notifying: requestor
  131.     | method |
  132.     method _ self compile: code.
  133.     method isNil ifTrue:
  134.     [ ^requestor error: 'Compilation failed' ].
  135.     ^method
  136. !
  137.  
  138. recompile: selector
  139.     self compile: (self sourceCodeAt: selector)
  140. !
  141.  
  142. decompile: selector
  143.     | method source |
  144.     method _ self compiledMethodAt: selector.
  145.     source _ method methodSourceString.
  146.     source isNil
  147.         ifTrue: [ ^self error: 'decompiler can''t decompile methods without source (yet)' ]
  148.     ifFalse: [ ^source ]
  149. !
  150.  
  151. edit: selector
  152.     | method sourceFile sourcePos |
  153.     method _ self compiledMethodAt: selector.
  154.     sourceFile _ method methodSourceFile.
  155.     sourceFile isNil
  156.         ifTrue: [ ^self error: 'decompiler can''t decompile methods without source (yet)' ].
  157.     sourcePos _ method methodSourcePos.
  158.     Smalltalk system: 'emacs -l st -smalltalk ', sourceFile, ' ', sourcePos printString
  159. !
  160.  
  161. compileAll
  162.     methodDictionary notNil
  163.     ifTrue: [ methodDictionary keysDo: 
  164.               [ :selector | self recompile: selector ] ]
  165. !
  166.  
  167. compileAllSubclasses
  168.     self allSubclassesDo: [ :subclass | subclass compileAll ]
  169. !!
  170.  
  171.  
  172.  
  173. !Behavior methodsFor: 'creating a class hierarchy'!
  174.  
  175. superclass: aClass
  176.     superClass _ aClass
  177. !
  178.  
  179. addSubclass: aClass
  180.     subClasses isNil 
  181.     ifTrue: [ subClasses _ Array new: 0 ]
  182.     ifFalse: [ "remove old class if any"
  183.           subClasses _ subClasses copyWithout: aClass ].
  184.     subClasses _ subClasses copyWith: aClass
  185. !
  186.  
  187. removeSubclass: aClass
  188.     subClasses _ subClasses copyWithout: aClass
  189. !!
  190.  
  191.  
  192.  
  193. !Behavior methodsFor: 'accessing the methodDictionary'!
  194.  
  195. selectors
  196.     methodDictionary isNil
  197.         ifTrue: [ ^Set new ]
  198.     ifFalse: [ ^methodDictionary keys ]
  199. !
  200.  
  201. allSelectors
  202.     | aSet |
  203.     aSet _ self selectors.
  204.     self allSuperclassesDo:
  205.         [ :superclass | aSet addAll: superclass selectors ].
  206.     ^aSet
  207. !
  208.  
  209. compiledMethodAt: selector
  210.     "Return the compiled method associated with selector, from the local
  211.     method dictionary.  Error if not found."
  212.     ^methodDictionary at: selector
  213. !
  214.  
  215. sourceCodeAt: selector
  216.     | method |
  217.     method _ self compiledMethodAt: selector.
  218.     ^method methodSourceString
  219. !
  220.  
  221. sourceMethodAt: selector
  222.     "This is too dependent on the original implementation"
  223.     self shouldNotImplement
  224. !!
  225.  
  226.  
  227.  
  228. !Behavior methodsFor: 'accessing instances and variables'!
  229.  
  230. allInstances
  231.     "Returns a set of all instances of the receiver"
  232.     | aSet |
  233.     aSet _ Set new.
  234.     self allInstancesDo: [ :anInstance | aSet add: anInstance ].
  235.     ^aSet
  236. !
  237.  
  238. instanceCount
  239.     | count anInstance |
  240.     count _ 0.
  241.     anInstance _ self someInstance.
  242.     [ anInstance notNil ]
  243.         whileTrue: [ count _ count + 1.
  244.                  anInstance _ anInstance nextInstance ].    
  245.     ^count
  246. !
  247.     
  248. instVarNames
  249.     self subclassResponsibility "### is this right?  Why is it here instead of
  250.                                  in ClassDescription?"
  251. !
  252.  
  253. subclassInstVarNames
  254.     self subclassResponsibility
  255. !
  256.  
  257. allInstVarNames
  258.     self subclassResponsibility
  259. !
  260.  
  261. classVarNames
  262.     self subclassResponsibility 
  263. !
  264.  
  265. allClassVarNames
  266.     self subclassResponsibility
  267. !
  268.  
  269. sharedPools
  270.     self subclassResponsibility
  271. !
  272.  
  273. allSharedPools
  274.     self subclassResponsibility
  275. !!
  276.  
  277.  
  278.  
  279. !Behavior methodsFor: 'accessing class hierarchy'!
  280.  
  281. subclasses
  282.     subClasses isNil
  283.     ifTrue: [ ^Set new ]
  284.     ifFalse: [ ^subClasses asSet ]
  285. !
  286.  
  287. allSubclasses
  288.     | aSet |
  289.     aSet _ Set new.
  290.     self allSubclassesDo: [ :subclass | aSet add: subclass ].
  291.     ^aSet
  292. !
  293.  
  294. withAllSubclasses
  295.     | aSet |
  296.     aSet _ Set with: self.
  297.     aSet addAll: (self allSubclasses).
  298.     ^aSet
  299. !
  300.  
  301. superclass
  302.     ^superClass
  303. !
  304.  
  305. allSuperclasses
  306.     | supers |
  307.     supers _ OrderedCollection new.
  308.     self allSuperclassesDo:
  309.         [ :superclass | supers addLast: superclass ].
  310.     ^supers
  311. !!
  312.  
  313.  
  314.  
  315. !Behavior methodsFor: 'testing the method dictionary'!
  316.  
  317. hasMethods
  318.     ^methodDictionary notNil and: [ methodDictionary size ~= 0 ]
  319. !
  320.  
  321. includesSelector: selector
  322.     "Returns true if the local method dictionary"
  323.     ^methodDictionary notNil and: [ methodDictionary includesKey: selector ]
  324. !
  325.  
  326. canUnderstand: selector
  327.     (self includesSelector: selector)
  328.         ifTrue: [ ^true ].
  329.     self allSuperclassesDo:
  330.         [ :superclass | (superclass includesSelector: selector)
  331.                         ifTrue: [ ^true ] ].
  332.     ^false
  333. !
  334.  
  335. whichClassIncludesSelector: selector
  336.     self allSuperclassesDo:
  337.         [ :superclass | (superclass includesSelector: selector)
  338.                         ifTrue: [ ^superclass ] ].
  339.     ^nil
  340. !
  341.  
  342. whichSelectorsAccess: instVarName
  343.     self notYetImplemented
  344. !
  345.  
  346. whichSelectorsReferTo: anObject
  347.     "Returns a Set of selectors that refer to anObject"
  348.     | s method |
  349.     s _ Set new.
  350.     methodDictionary isNil
  351.     ifTrue: [ ^s ].
  352.     methodDictionary associationsDo:
  353.     [ :assoc |  method _ assoc value.
  354.             1 to: method numLiterals do:
  355.             [ :i | (method literalAt: i) == anObject
  356.                    ifTrue: [ s add: assoc key ]
  357.                    ]
  358.             ].
  359.     ^s
  360. !
  361.  
  362. scopeHas: name ifTrue: aBlock
  363.     | nameSym |
  364.     nameSym _ name asSymbol.
  365.     ((self allInstVarNames) includes: nameSym) ifTrue: [ ^aBlock value ].
  366.     ((self allClassVarNames) includes: nameSym) ifTrue: [ ^aBlock value ].
  367.     (self allSharedPools) do:
  368.     [ :dictName | ((Smalltalk at: dictName asSymbol) includesKey: nameSym)
  369.               ifTrue: [ ^aBlock value ] ]
  370. !!
  371.  
  372.  
  373.  
  374. !Behavior methodsFor: 'testing the form of the instances'!
  375.  
  376. isPointers
  377.     "Due to our representation bit 30 is inverted, so we invert the sense
  378.     of this test, and things work out fine."
  379.     ^(self instanceSpec bitAt: 30) = 0
  380. !
  381.  
  382. isBits
  383.     ^self isPointers not
  384. !
  385.  
  386. isBytes
  387.     ^self isPointers not & self isWords not
  388. !
  389.  
  390. isWords
  391.     ^(self instanceSpec bitAt: 29) ~= 0
  392. !
  393.  
  394. isFixed
  395.     ^self isVariable not
  396. !
  397.  
  398. isVariable
  399.     ^(self instanceSpec bitAt: 28) ~= 0
  400. !
  401.  
  402. instSize
  403.     ^self instanceSpec bitAnd: 16r0FFFFFFF
  404. !!
  405.  
  406.  
  407.  
  408. !Behavior methodsFor: 'testing the class hierarchy'!
  409.  
  410. inheritsFrom: aClass
  411.     "Returns true if aClass is a superclass of the receiver"
  412.     | sc |
  413.     sc _ self.
  414.     [ sc _ sc superclass.
  415.       sc isNil ]
  416.         whileFalse:
  417.         [ sc == aClass ifTrue: [ ^true ] ].
  418.     ^false
  419. !
  420.  
  421. kindOfSubclass
  422.     self isVariable
  423.         ifTrue: [ self isBytes ifTrue: [ ^'variableByteSubclass: ' ].
  424.               self isPointers
  425.             ifTrue: [ ^'variableSubclass: ' ]
  426.             ifFalse: [ ^'variableWordSubclass: ' ] ]
  427.     ifFalse: [ ^'subclass: ' ]
  428. !!
  429.  
  430.  
  431.  
  432. !Behavior methodsFor: 'enumerating'!
  433.  
  434. allSubclassesDo: aBlock
  435.     "Invokes aBlock for all subclasses, both direct and indirect."
  436.     subClasses notNil
  437.     ifTrue: [ subClasses do: [ :class | aBlock value: class.
  438.                         class allSubclassesDo: aBlock ]
  439.               ]
  440. !
  441.  
  442. allSuperclassesDo: aBlock
  443.     | class superclass |
  444.     class _ self.
  445.     [ superclass _ class superclass.
  446.       class _ superclass.
  447.       superclass notNil ] whileTrue:
  448.           [ aBlock value: superclass ]
  449. !
  450.  
  451. allInstancesDo: aBlock
  452.     | anInstance |
  453.     anInstance _ self someInstance.
  454.     [ anInstance notNil ]
  455.         whileTrue: [ aBlock value: anInstance.
  456.                  anInstance _ anInstance nextInstance ]
  457. !
  458.  
  459. allSubinstancesDo: aBlock
  460.     self allSubclassesDo:
  461.         [ :subclass | subclass allInstancesDo: aBlock ]
  462. !
  463.  
  464. selectSubclasses: aBlock
  465.     | aSet |
  466.     aSet _ Set new.
  467.     self allSubclassesDo: [ :subclass | (aBlock value: subclass)
  468.                                             ifTrue: [ aSet add: subclass ] ].
  469.     ^aSet
  470. !
  471.  
  472. selectSuperclasses: aBlock
  473.     | aSet |
  474.     aSet _ Set new.
  475.     self allSuperclassesDo: [ :superclass | (aBlock value: superclass)
  476.                                             ifTrue: [ aSet add: superclass ] ].
  477.     ^aSet
  478. !!
  479.  
  480.  
  481.  
  482. !Behavior methodsFor: 'conditional compilation'!
  483.  
  484. methodsFor: category ifFeatures: features
  485.     ^self methodsFor: category ifTrue: (Smalltalk hasFeatures: features)
  486. !!
  487.  
  488.  
  489.  
  490. !Behavior methodsFor: 'private'!
  491.  
  492. instanceSpec
  493.     ^instanceSpec
  494. !
  495.  
  496. setInstanceSpec: variableBoolean
  497.   words: wordsBoolean
  498.   pointers: pointersBoolean
  499.   instVars: anIntegerSize
  500.     instanceSpec _ 0.
  501.     "Due to our representation bit 30 is inverted, so we invert the sense
  502.     of this test, and things work out fine."
  503.     pointersBoolean
  504.         ifFalse: [ instanceSpec _ instanceSpec bitOr: ( 1 bitShift: 30 ) ].
  505.     wordsBoolean
  506.         ifTrue: [ instanceSpec _ instanceSpec bitOr: ( 1 bitShift: 29 ) ].
  507.     variableBoolean
  508.         ifTrue: [ instanceSpec _ instanceSpec bitOr: ( 1 bitShift: 28 ) ].
  509.     instanceSpec _ instanceSpec bitOr: (anIntegerSize bitAnd: 16r0FFFFFFF).
  510. !!
  511.